home *** CD-ROM | disk | FTP | other *** search
- C---------------------------------------------------------------------------
-
- C Program name: Menus test program.
-
- C Author: Gareth Williams
-
- C Description:
-
- C Modification history : (Version), (Date), (Name), (Description).
-
- C 1.0, 1st March 1991, G. Williams, First Version.
-
- C----------------------------------------------------------------------------
-
- C--------------------------------------------------------------------------
-
- PROGRAM menutest
- LOGICAL menuquit, picked
- INTEGER itemnum
- INTEGER ptkf_stringtoint
- LOGICAL ptkf_readphinterscript
- LOGICAL getmenupick
- LOGICAL docolour
-
- include './sunphigs77.h'
- include './sunptk77.h'
-
- implicit undefined (P, p, E, e)
-
- C open PHIGS
- print *,('Testing the menus utility of the PHIGS Toolkit...')
- print *,('Opening SunPHIGS...')
-
- call popph(6, 0)
-
- C create the workstation type (either tool or canvas)
-
- C open the workstation
-
- if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
- & .FALSE.) then
- goto 20
- endif
-
- C define colour variable
- C for a MONOCHROME workstation set this value to .FALSE.
-
- docolour = .TRUE.
-
- call psdus(1, PWAITD, PNIVE)
-
- call ptkf_inithashtables()
- call ptkf_createhashtable('structureid', 0, 100)
- call ptkf_createhashtable('viewindex', 1, 100)
- call ptkf_createhashtable('label', 0, 100)
- call ptkf_createhashtable('nameset', 0, 100)
- call ptkf_createhashtable('menuid', 1, 100)
- call ptkf_createhashtable('colourindex', 1, 100)
- call ptkf_createhashtable('name', 1, 100)
-
- C set colours
- if (docolour .eq. .TRUE.) then
- call ptkf_setcolourrep(1, 'black')
- call ptkf_setcolourrep(1, 'GREEN')
- call ptkf_setcolourrep(1, 'white')
- call ptkf_setcolourrep(1, 'MEDIUM GREEN')
- call ptkf_setcolourrep(1, 'MAGENTA')
- call ptkf_setcolourrep(1, 'MEDIUM MAGENTA')
- call ptkf_setcolourrep(1, 'GREY')
-
- call ptkf_setbackgroundcolourind(1,
- & ptkf_stringtoint('colourindex', 'grey'))
- endif
-
- C menus to select type of menu and type of input
-
- call makemainmenu(docolour)
-
- call makeinputmenu(docolour)
-
- C create test box, user and rotator menus
-
- call createbox(docolour)
-
- call createrotator(docolour)
-
- C interaction loop
- C draw main menu
-
- menuquit = .FALSE.
- 10 call ptkf_postmenu(1, ptkf_stringtoint('menuid',
- & 'mainmenu'))
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',
- & 'inputmenu'))
- call prst(1, PALWAY)
-
- itemnum = 0
- picked = getmenupick(ptkf_stringtoint('menuid', 'mainmenu'),
- & itemnum)
- if (picked .eq. .TRUE.) then
- if (itemnum .eq. 1) then
- call testboxmenu()
- else if (itemnum .eq. 2) then
- call testrotator()
- else
- menuquit = .TRUE.
- endif
- else
- print *,('You didnt pick a menu.')
- endif
-
- if (menuquit .eq. .TRUE.) then
- goto 20
- else
- goto 10
- endif
-
- 20 print *,('Closing PHIGS...')
- call pclwk(1)
- call pclph()
-
- STOP
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE pickinput(itemnum)
- INTEGER itemnum, err
- INTEGER menuset(20), emptyset(20), menunames(20)
- INTEGER totsize, i
- REAL pickecho(4)
- INTEGER stat, ppd
- INTEGER pp(3, 20), ppath(3, 20)
- INTEGER ia(2), ldr, err, lstr(1)
- REAL rl(4)
- CHARACTER*80 str, datrec(10)
- LOGICAL picked
- LOGICAL ptkf_pickscanmenus
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- C test picking
- itemnum = 0
- print *,('Pick a menu item...')
- C initialise pick
-
- call ptkf_inqpostedmenus(1, 20, menuset, totsize, err)
- do 10, i=1,totsize
- call ptkf_inqmenuname(menuset(i), menunames(i), err)
- 10 continue
-
- call pspkft(1, 1, totsize, menunames, 0, emptyset)
-
- call ptkf_limit(0.0, 1.0, 0.0, 1.0, pickecho)
-
- ia(1) = 2
- ia(2) = 2
- rl(1) = 0.3
- rl(2) = 1.0
-
- call pprec(2, ia, 2, rl, 0, lstr, str, 10, err, ldr, datrec)
-
- call pinpk(1, 1, PNPICK, 0, pp, 2, 0.0, 1.0, 0.0, 1.0,
- & ldr, datrec, PPOBOT)
-
- C set pick
- call pspkm(1, 1, PREQU, PECHO)
-
- C request pick
-
- call prqpk(1, 1, 10, stat, ppd, ppath)
-
- if (stat .eq. POK) then
- picked = ptkf_pickscanmenus(ppd, ppath, PPOBOT, menuid,
- & itemnum)
- if (picked .eq. .TRUE.) then
- print *,'menu item', itemnum, 'was picked from menu',
- & menuid
- else
- print *,('You did not pick a menu.')
- endif
- else
- print *,('Nothing picked.')
- endif
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- LOGICAL FUNCTION getmenupick(menuid, itemnum)
- INTEGER menuid, itemnum, err
- INTEGER pmenuid
- REAL pickecho(4)
- INTEGER menuset(10), emptyset(10)
- INTEGER stat, ppd
- INTEGER pp(3, 20), ppath(3, 20)
- INTEGER ia(2), ldr, err, lstr(1)
- REAL rl(4)
- CHARACTER*80 str, datrec(10)
- LOGICAL ptkf_pickscanmenus
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- C make menu pickable
- call ptkf_inqmenuname(menuid, menuset(1), err)
- call pspkft(1, 1, 1, menuset, 0, emptyset)
-
- call ptkf_limit(0.0, 1.0, 0.0, 1.0, pickecho)
-
- ia(1) = 2
- ia(2) = 2
- rl(1) = 0.3
- rl(2) = 1.0
-
- call pprec(2, ia, 2, rl, 0, lstr, str, 10, err, ldr, datrec)
-
- call pinpk(1, 1, PNPICK, 0, pp, 2, 0.0, 1.0, 0.0, 1.0, ldr,
- & datrec, PPOBOT)
-
- C set pick
- call pspkm(1, 1, PREQU, PECHO)
-
- C request pick
-
- call prqpk(1, 1, 10, stat, ppd, ppath)
-
- if (stat .eq. POK) then
- getmenupick = ptkf_pickscanmenus(ppd, ppath, PPOBOT,
- & pmenuid, itemnum)
- else
- getmenupick = .FALSE.
- endif
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE pointinput(itemnum)
- INTEGER itemnum
- REAL echovol(4)
- CHARACTER*80 datrec
- INTEGER stat, view
- REAL point(2)
- INTEGER menuid
- REAL value(2)
- LOGICAL picked
- LOGICAL ptkf_locscanmenus
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- itemnum = 0
- print *,('Point at a menu item...')
- echovol(1) = 0.0
- echovol(3) = 0.0
- echovol(2) = 1.0
- echovol(4) = 1.0
- call pinlc(1, 1, 0, 0.5, 0.5, 1, 0.0, 1.0, 0.0, 1.0, 0,
- & datrec)
- call pslcm(1, 1, PREQU, PECHO)
- call prqlc(1, 1, stat, view, point(1), point(2))
- if (stat .eq. POK) then
- picked = ptkf_locscanmenus(1, point, menuid, itemnum,
- & value)
- if (picked .eq. .TRUE.) then
- print *,'menu item', itemnum, 'was pointed at from menu',
- & menuid
- print *,'value, x =', value(1), 'y =', value(2)
- endif
- else
- print *,('You did not point at a menu.')
- endif
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE stringinput(itemnum)
- INTEGER itemnum
- CHARACTER*30 dummystr
- INTEGER dummylen
- REAL echoarea(4)
- LOGICAL picked
- LOGICAL ptkf_stringscanmenus
-
- implicit undefined (P, p, E, e)
-
- itemnum = 0
- print *,('Enter a menu item...')
- call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
- call ptkf_readstring(1, '', 'Type menu item name >', echoarea,
- & 30, dummystr, dummylen)
- picked = ptkf_stringscanmenus(1, dummystr, menuid, itemnum)
- if (picked .eq. .TRUE.) then
- print *,'menu item', itemnum, 'was entered from menu',
- & menuid
- else
- print *,('No menu item of that name.')
- endif
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE makemainmenu(docolour)
- LOGICAL docolour
- INTEGER err
- REAL topleft(2), box(2)
- INTEGER textind
- REAL charht
- INTEGER white, green, black
- INTEGER mainmenuid
- INTEGER ptkf_stringtoint
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- C create a BOX menu
- C set up main menu - box menu(box, user, rotator, exit)
-
- mainmenuid = ptkf_stringtoint('menuid', 'mainmenu')
- call ptkf_point(0.2, 0.1, box)
- textind = 1
- charht = 0.025
- call ptkf_point(0.8, 1.0, topleft)
-
- call ptkf_createboxmenu(mainmenuid, topleft, box)
-
- if (docolour .eq. .TRUE.) then
- white = ptkf_stringtoint('colourindex', 'white')
- green = ptkf_stringtoint('colourindex', 'green')
- black = ptkf_stringtoint('colourindex', 'black')
- call ptkf_setboxmenuattrs(1, mainmenuid, PDOWN, 1,
- & white, green, green, white, black, white, green, green)
- endif
-
- call ptkf_createtextmenuitem(mainmenuid, 'box', 1, PINSRT, err)
- call ptkf_createtextmenuitem(mainmenuid, 'rotator', 2, PINSRT,
- & err)
- call ptkf_createtextmenuitem(mainmenuid, 'exit', 3, PINSRT,
- & err)
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE makeinputmenu(docolour)
- LOGICAL docolour
- INTEGER err
- REAL topleft(2), box(2)
- INTEGER textind
- REAL charht
- INTEGER white, magenta, black, darkmagenta
- INTEGER inputmenuid
- INTEGER ptkf_stringtoint
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- inputmenuid = ptkf_stringtoint('menuid', 'inputmenu')
- call ptkf_point(0.2, 0.1, box)
- textind = 1
- charht = 0.03
- call ptkf_point(0.8, 0.5, topleft)
-
- call ptkf_createboxmenu(inputmenuid, topleft, box)
-
- if (docolour .eq. .TRUE.) then
- white = ptkf_stringtoint('colourindex', 'white')
- magenta = ptkf_stringtoint('colourindex', 'magenta')
- darkmagenta = ptkf_stringtoint('colourindex',
- & 'medium magenta')
- black = ptkf_stringtoint('colourindex', 'black')
- call ptkf_setboxmenuattrs(1, inputmenuid, PDOWN, 1,
- & white, magenta, magenta, white, black, white, darkmagenta,
- & darkmagenta)
- endif
-
- call ptkf_createtextmenuitem(inputmenuid, 'pick', 1, PINSRT,
- & err)
- call ptkf_createtextmenuitem(inputmenuid, 'point', 2, PINSRT,
- & err)
- call ptkf_createtextmenuitem(inputmenuid, 'string', 3, PINSRT,
- & err)
- call ptkf_createtextmenuitem(inputmenuid, 'exit', 4, PINSRT,
- & err)
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE createbox(docolour)
- LOGICAL docolour
- INTEGER err
- REAL topleft(2), box(2)
- INTEGER textind
- REAL charht
- INTEGER white, green, black, darkgreen
- INTEGER boxmenuid
- INTEGER ptkf_stringtoint
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- boxmenuid = ptkf_stringtoint('menuid', 'boxmenu')
- call ptkf_point(0.2, 0.1, box)
- textind = 1
- charht = 0.03
- call ptkf_point(0.0, 0.0, topleft)
-
- call ptkf_createboxmenu(boxmenuid, topleft, box)
-
- if (docolour .eq. .TRUE.) then
- white = ptkf_stringtoint('colourindex', 'white')
- green = ptkf_stringtoint('colourindex', 'green')
- darkgreen = ptkf_stringtoint('colourindex', 'medium green')
- black = ptkf_stringtoint('colourindex', 'black')
- call ptkf_setboxmenuattrs(1, boxmenuid, PDOWN, 1,
- & white, green, green, white, black, white, darkgreen, darkgreen)
-
- endif
-
- call ptkf_point(0.5, 0.7, topleft)
- call ptkf_setmenuposition(boxmenuid, topleft)
-
- call ptkf_createtextmenuitem(boxmenuid, 'item 1', 1, PINSRT,
- & err)
- call ptkf_createtextmenuitem(boxmenuid, 'item 2', 2, PINSRT,
- & err)
- call ptkf_createtextmenuitem(boxmenuid, 'item 3', 3, PINSRT,
- & err)
- call ptkf_createtextmenuitem(boxmenuid, 'item 4', 4, PINSRT,
- & err)
-
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE createrotator(docolour)
- LOGICAL docolour
- REAL size(2), pos(2)
- INTEGER green, white, black
- INTEGER rotator1, rotator2, rotator3
- INTEGER ptkf_stringtoint
-
- include './sunptk77.h'
-
- implicit undefined (P, p, E, e)
-
- C create a rotator
- rotator1 = ptkf_stringtoint('menuid', '1drotator')
- rotator2 = ptkf_stringtoint('menuid', '2drotator')
- rotator3 = ptkf_stringtoint('menuid', '3drotator')
- call ptkf_point(0.2, 0.2, size)
- call ptkf_createrotator(1, rotator1, PTKEONED, size,
- & '1D rotator', 0.02)
- call ptkf_createrotator(1, rotator2, PTKETWOD, size,
- & '2D rotator', 0.02)
- call ptkf_point(0.3, 0.2, size)
- call ptkf_createrotator(1, rotator3, PTKETHREED, size,
- & '3D rotator', 0.02)
- if (docolour .eq. .TRUE.) then
- green = ptkf_stringtoint('colourindex', 'green')
- white = ptkf_stringtoint('colourindex', 'white')
- black = ptkf_stringtoint('colourindex', 'black')
- call ptkf_setrotatorattrs(1, rotator1, 1, white, green,
- & white, green, white, green, white, black)
- call ptkf_setrotatorattrs(1, rotator2, 1, white, green,
- & white, green, white, green, white, black)
- call ptkf_setrotatorattrs(1, rotator3, 1, white, green,
- & white, green, white, green, white, black)
- endif
-
- call ptkf_point(0.5, 0.3, pos)
- call ptkf_setmenuposition(rotator1, pos)
- call ptkf_point(0.5, 0.55, pos)
- call ptkf_setmenuposition(rotator2, pos)
- call ptkf_point(0.5, 0.8, pos)
- call ptkf_setmenuposition(rotator3, pos)
-
- call ptkf_setrotatortitle(rotator1, 'zoom')
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE testboxmenu()
- LOGICAL boxmenuquit, picked
- INTEGER itemnum
- LOGICAL getmenupick
- INTEGER ptkf_stringtoint
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid', 'mainmenu'))
- call ptkf_postmenu(1, ptkf_stringtoint('menuid', 'inputmenu'))
- call ptkf_postmenu(1, ptkf_stringtoint('menuid', 'boxmenu'))
-
- call prst(1, PALWAY)
- boxmenuquit = .FALSE.
-
- 10 itemnum = 0
- picked = getmenupick(ptkf_stringtoint('menuid', 'inputmenu'),
- & itemnum)
- if (picked .eq. .TRUE.) then
-
- call ptkf_setboxmenuhighlightitem(ptkf_stringtoint('menuid',
- & 'inputmenu'), itemnum)
- call prst(1, PALWAY)
-
- if (itemnum .eq. 1) then
- call pickinput(itemnum)
- call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
- & 'menuid', 'boxmenu'), itemnum)
- else if (itemnum .eq. 2) then
- call pointinput(itemnum)
- call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
- & 'menuid', 'boxmenu'), itemnum)
- else if (itemnum .eq. 3) then
- call stringinput(itemnum)
- call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
- & 'menuid', 'boxmenu'), itemnum)
- else
- boxmenuquit = .TRUE.
- endif
- endif
-
- call prst(1, PALWAY)
-
- if (boxmenuquit .eq. .TRUE.) then
- goto 20
- else
- goto 10
- endif
-
- 20 call ptkf_clearboxmenuhighlight(ptkf_stringtoint('menuid',
- & 'inputmenu'))
- call ptkf_clearboxmenuhighlight(ptkf_stringtoint('menuid',
- & 'boxmenu'))
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid', 'boxmenu'))
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- SUBROUTINE testrotator()
- LOGICAL rotatorquit, picked
- INTEGER err, itemnum
- LOGICAL getmenupick
- INTEGER ptkf_stringtoint
-
- include './sunphigs77.h'
-
- implicit undefined (P, p, E, e)
-
- call ptkf_delmenuitem(ptkf_stringtoint('menuid',
- & 'inputmenu'), 3)
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',
- & 'mainmenu'))
- call ptkf_postmenu(1, ptkf_stringtoint('menuid',
- & 'inputmenu'))
-
- call ptkf_postmenu(1, ptkf_stringtoint('menuid',
- & '1drotator'))
- call ptkf_postmenu(1, ptkf_stringtoint('menuid',
- & '2drotator'))
- call ptkf_postmenu(1, ptkf_stringtoint('menuid',
- & '3drotator'))
- call prst(1, PALWAY)
- rotatorquit = .FALSE.
- 10 itemnum = 0
- picked = getmenupick(ptkf_stringtoint('menuid', 'inputmenu'),
- & itemnum)
- if (picked .eq. .TRUE.) then
- if (itemnum .eq. 1) then
- call pickinput(itemnum)
- else if (itemnum .eq. 2) then
- call pointinput(itemnum)
- else
- rotatorquit = .TRUE.
- endif
- endif
-
- if (rotatorquit .eq. .TRUE.) then
- goto 20
- else
- goto 10
- endif
-
- 20 call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',
- & '1drotator'))
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',
- & '2drotator'))
- call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',
- & '3drotator'))
- call ptkf_createtextmenuitem(ptkf_stringtoint('menuid',
- & 'inputmenu'), 'string', 3, PINSRT, err)
-
- RETURN
- END
-
- C--------------------------------------------------------------------------
-
- C end of menutest.f
-